home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 22 / Cream of the Crop 22.iso / os2 / ftree11a.zip / EXGEDCOM.FTX < prev    next >
Text File  |  1996-10-30  |  9KB  |  311 lines
  1. /*
  2.    Family Tree Rexx Script FTX
  3.  
  4.    Copyright (C) 1996 by <Nils Meier>
  5.  
  6.    Please send comments to / Kommentar bitte an
  7.         meier2@athene.informatik.uni-bonn.de
  8.  
  9.    <
  10.    English:   This script exports the family tree to a GEDCOM file.            :English
  11.    Deutsch:   Dieses Skript exportiert den Stammbaum in eine GEDCOM Datei.     :Deutsch
  12.    Nederlands:This script exports the family tree to a GEDCOM file.            :Nederlands
  13.    Francais:  Ce script exporte l'arbre généalogique vers un fichier au format
  14.               GEDCOM.                                                          :Francais
  15.    >
  16.  
  17.    Long name is <
  18.                  English:    Export to GEDCOM-format   :English
  19.                  Deutsch:    GEDCOM-Format exportieren :Deutsch
  20.                  Nederlands: Export to GEDCOM-format   :Nederlands
  21.                  Francais:   Exporte au format GEDCOM  :Francais
  22.                 >
  23. */
  24.  
  25. CALL RxFuncAdd 'SysFileDelete', 'RexxUtil', 'SysFileDelete'
  26.  
  27. /* ----------------------- Params  /  Parameter ------------------- */
  28. namewidth=30
  29.  
  30. datasex   = ' MF'
  31. datamonth = 'JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC'
  32. datamod   = 'ABT AFT BEF EST'
  33.  
  34. CALL InitLanguage
  35.  
  36. /* ----------------- Display Header / Kopf der Ausgabe ------------- */
  37. head=msg.Header.LANG||DATE()
  38. SAY(head)
  39. SAY(COPIES('=',length(head)))
  40.  
  41.  
  42. /* ------------------- Open file  /  Datei oeffnen  ---------------- */
  43. filename=getFileName(select,'*.GED')
  44. IF filename='' THEN DO
  45.    SAY(msg.Done.LANG)
  46.    RETURN
  47.    END
  48.  
  49. rc=SysFileDelete(filename)
  50. rc=rc+LINEOUT(filename,,1)
  51. IF (rc=1) THEN DO
  52.    SAY(msg.Fileerror.LANG||filename)
  53.    RETURN
  54.    END
  55.  
  56. /* -------------- Header of GEDCOM  /  Kopf von GEDCOM -------------- */
  57.  
  58. SAY(msg.Exporthead.LANG)
  59.  
  60. rc=LINEOUT(filename,'0 HEAD')
  61. rc=LINEOUT(filename,'1 SOUR FamilyTree for OS/2 - ExGedcom.ftx')
  62. rc=LINEOUT(filename,'2 VERS 1.1a')
  63. rc=LINEOUT(filename,'1 CHAR IBMPC')
  64. rc=LINEOUT(filename,'1 FILE '||FILESPEC('name',filename))
  65. rc=LINEOUT(filename,'1 DATE '||DATE())
  66.  
  67. /* ------------ Export Persons  /  Personen exportieren -------------- */
  68.  
  69. SAY(msg.Exportindis.LANG)
  70.  
  71. rc=selectPerson('F')
  72. DO WHILE RC=1
  73.    /* Export this one / Diesen exportieren */
  74.    call ExportPerson
  75.    /* Next one / Naechster */
  76.    rc=selectPerson('N')
  77. END
  78.  
  79. /* ------------ Export Families  /  Familien exportieren -------------- */
  80.  
  81. SAY(msg.Exportfams.LANG)
  82.  
  83. rc=selectFamily('F')
  84. DO WHILE RC=1
  85.    /* Export this one / Diesen exportieren */
  86.    call ExportFamily
  87.    /* Next one / Naechster */
  88.    rc=selectFamily('N')
  89. END
  90.  
  91. /* ------------------- Close File  /  Datei schliessen -------------- */
  92. rc=LINEOUT(filename,'0 TRLR')
  93. rc=LINEOUT(filename)
  94.  
  95. /* ------------------------ Done / Fertig ---------------------------*/
  96. SAY(msg.Done.LANG)
  97. RETURN
  98.  
  99.  
  100.  
  101. /* =============== Auxilary Functions / Hilfsfunktionen =============== */
  102.  
  103.  
  104. /* --------------- Export Person  /  Person exportieren ---------------- */
  105. ExportFamily:
  106.  
  107.    /* Standard data  /  Standarddaten */
  108.  
  109.    rc=LINEOUT(filename,'0 @F'||getFID()||'@ FAM')
  110.  
  111.    tag='HUSB'
  112.    rc=selectPerson('f')
  113.    fSex=getSex()
  114.    fID =getPID()
  115.    rc=selectPerson('m')
  116.    mSex=getSex()
  117.    mID =getPID()
  118.    IF (fSex=2)|(mSex=1) THEN DO
  119.       tID=fID
  120.       fID=mID
  121.       mID=tID
  122.       END
  123.    rc=LINEOUT(filename,'1 HUSB @I'||fID||'@')
  124.    rc=LINEOUT(filename,'1 WIFE @I'||mID||'@')
  125.  
  126.    rc=LINEOUT(filename,'1 MARR')
  127.    rc=LINEOUT(filename,'2 DATE '||calcDate(getMarriageDate('O'),getMarriageDate('D'),getMarriageDate('M'),getMarriageDate('Y')))
  128.    rc=LINEOUT(filename,'2 PLAC '||getMarriagePlace())
  129.  
  130.    rc=LINEOUT(filename,'1 DIV')
  131.    rc=LINEOUT(filename,'2 DATE '||calcDate(getDivorceDate('O'),getDivorceDate('D'),getDivorceDate('M'),getDivorceDate('Y')))
  132.  
  133.    /* Children  /  Kinder */
  134.    c=1
  135.    DO FOREVER
  136.       rc=selectPerson(c)
  137.       IF rc=0 THEN LEAVE
  138.       rc=LINEOUT(filename,'1 CHIL @I'||getPID()||'@')
  139.       c=c+1
  140.    END
  141.  
  142.    /* Done / Fertig */
  143.    RETURN
  144.  
  145.  
  146. /* --------------- Export Person  /  Person exportieren ---------------- */
  147. ExportPerson:
  148.  
  149.    /* Personal Data  /  persoenliche Daten */
  150.  
  151.    rc=LINEOUT(filename,'0 @I'||getPID()||'@ INDI')
  152.    rc=LINEOUT(filename,'1 NAME '||getFirstName()||' /'||getName()||'/')
  153.    rc=LINEOUT(filename,'1 SEX '||SUBSTR(datasex,getSex()+1,1))
  154.    rc=LINEOUT(filename,'1 BIRT')
  155.    rc=LINEOUT(filename,'2 DATE '||calcDate(getBirthDate('O'),getBirthDate('D'),getBirthDate('M'),getBirthDate('Y')))
  156.    rc=LINEOUT(filename,'2 PLAC '||getBirthPlace())
  157.    rc=LINEOUT(filename,'1 DEAT')
  158.    rc=LINEOUT(filename,'2 DATE '||calcDate(getDeathDate('O'),getDeathDate('D'),getDeathDate('M'),getDeathDate('Y')))
  159.    rc=LINEOUT(filename,'2 PLAC '||getDeathPlace())
  160.  
  161.    temp=getPicture()
  162.    IF temp<>'' THEN
  163.      rc=LINEOUT(filename,'1 PHOT '||temp)
  164.  
  165.    temp=getOccupation()
  166.    IF temp<>'' THEN
  167.       rc=LINEOUT(filename,'1 OCCU '||temp)
  168.  
  169.    temp=getAddress()
  170.    tag='1 ADDR '
  171.    DO WHILE temp<>''
  172.       p=POS(',',temp)
  173.       IF p=0 THEN p=LENGTH(temp)+1
  174.       rc=LINEOUT(filename,tag||SUBSTR(temp,1,p-1))
  175.       temp=SUBSTR(temp,p+1)
  176.       tag='2 CONT '
  177.    END
  178.  
  179.  
  180.    l=1
  181.    DO FOREVER
  182.       temp=getFile(l)
  183.       IF LENGTH(temp)=0 THEN LEAVE
  184.       rc=LINEOUT(filename,'1 FILE '||temp)
  185.       l=l+1
  186.    END
  187.  
  188.  
  189.    l=1
  190.    tag='1 NOTE '
  191.    DO FOREVER
  192.       temp=getMemo(l)
  193.       IF LENGTH(temp)=0 THEN LEAVE
  194.       rc=LINEOUT(filename,tag||temp)
  195.       tag='2 CONT '
  196.       l=l+1
  197.    END
  198.  
  199.    /* Families with partners  /  Familien mit Partnern */
  200.    f=1
  201.    DO FOREVER
  202.       rc=selectFamily(f)
  203.       IF rc=0 THEN LEAVE
  204.       rc=LINEOUT(filename,'1 FAMS @F'||getFID()||'@')
  205.       f=f+1
  206.    END
  207.  
  208.    /* Family of parents  /  Familie der Eltern */
  209.    rc=selectFamily('p')
  210.    IF rc=1 THEN
  211.       rc=LINEOUT(filename,'1 FAMC @F'||getFID()||'@')
  212.  
  213.    /* Done  /  Fertig */
  214.    RETURN
  215.  
  216.  
  217. /* --------------- Calculate Date  /  Datum berechnen ---------------- */
  218. calcDate:
  219.    IF ARG(1)=0 THEN mod=''
  220.    ELSE mod=WORD(datamod,ARG(1))
  221.  
  222.    day=ARG(2)
  223.    month=ARG(3)
  224.    year=ARG(4)
  225.  
  226.  
  227.    /* --- 'dd.mm.yyyy' -> 'dd mm yyyy' ---- */
  228.    IF (day>0)&(month>0)&(year>0) THEN
  229.       RETURN(mod day month year)
  230.  
  231.    /* --- '--.--.----' -> '' -------------- */
  232.    IF (day=0)&(month=0)&(year=0) THEN
  233.       RETURN('')
  234.  
  235.    /* --- '--.mm.yyyy' -> 'MMM yyyy ------- */
  236.    IF (day=0)&(month>0)&(year>0) THEN
  237.       RETURN(mod WORD(datamonth,month) year)
  238.  
  239.    /* --- '--.--.yyyy' -> 'yyyy' ---------- */
  240.    IF (day=0)&(month=0)&(year>0) THEN
  241.       RETURN(mod year)
  242.  
  243.    /* --- 'dd.mm.----' -> 'dd MMM' -------- */
  244.    IF (day>0)&(month>0)&(year=0) THEN
  245.       RETURN(mod day WORD(datamonth,month))
  246.  
  247.    /* --- '--.mm.----' -> 'MMM' ----------- */
  248.    IF (day=0)&(month>0)&(year=0) THEN
  249.       RETURN(mod WORD(datamonth,month))
  250.  
  251.    /* --- 'dd.--.yyyy' -> 'yyyy' ---------- */
  252.    IF (day>0)&(month=0)&(year>0) THEN
  253.       RETURN(mod year)
  254.  
  255.    /* --- 'dd.--.----' -> ''--------------- */
  256.    RETURN('')
  257.  
  258.  
  259. /* ---------------------- LANGUAGE INIT --------------------------- */
  260. InitLanguage:
  261.  
  262.    /* Calculate Language Index */
  263.    lang='E'                              /* Default -> [E]nglish */
  264.    IF getLanguage()='Deutsch' THEN       /* Deutsch -> [G]erman */
  265.       lang='G'
  266.    IF getLanguage()='Nederlands' THEN    /* Nederlands -> [D]utch */
  267.       lang='D'
  268.    IF getLanguage()='Francais' THEN      /* Francais -> [F]rench */
  269.       lang='F'
  270.  
  271.    /* [E]nglish Messages */
  272.    msg.Header.E     = 'Exporting to GEDCOM:'
  273.    msg.Select.E     = 'Select GEDCOM file for export:'
  274.    msg.Fileerror.E  = 'Error during writing to : '
  275.    msg.Exporthead.E = 'Exporting HEAD ...'
  276.    msg.Exportindis.E= 'Exporting INDIs ...'
  277.    msg.Exportfams.E = 'Exporting FAMs ...'
  278.    msg.Done.E       = 'Done !'
  279.  
  280.    /* [G]erman Messages */
  281.    msg.Header.G     = 'Exportiere nach GEDCOM:'
  282.    msg.Select.G     = 'GEDCOM-Export-Datei angeben:'
  283.    msg.Fileerror.G  = 'Fehler waehrend des Schreibens von : '
  284.    msg.Exporthead.G = 'Exportiere HEAD ...'
  285.    msg.Exportindis.G= 'Exportiere INDIs ...'
  286.    msg.Exportfams.G = 'Exportiere FAMs ...'
  287.    msg.Done.G       = 'Fertig !'
  288.  
  289.    /* [D]utch Messages */
  290.    msg.Header.D     = 'Exporting to GEDCOM:'
  291.    msg.Select.D     = 'Select GEDCOM file for export:'
  292.    msg.Fileerror.D  = 'Error during writing to : '
  293.    msg.Exporthead.D = 'Exporting HEAD ...'
  294.    msg.Exportindis.D= 'Exporting INDIs ...'
  295.    msg.Exportfams.D = 'Exporting FAMs ...'
  296.    msg.Done.D       = 'Done !'
  297.  
  298.    /* [F]rench Messages */
  299.    msg.Header.F     = "Export vers GEDCOM :"
  300.    msg.Select.F     = "Sélectionnez un fichier GEDCOM pour l'export :"
  301.    msg.Fileerror.F  = "Erreur durand l'écriture à : "
  302.    msg.Exporthead.F = "Export HEAD ..."
  303.    msg.Exportindis.F= "Export INDIs ..."
  304.    msg.Exportfams.F = "Export FAMs ..."
  305.    msg.Done.F       = "Fait !"
  306.  
  307.    /* Done */
  308.    RETURN
  309.  
  310.  
  311.